COMMENT ⊗   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 A simple Combinator interpreter based on production rules.
C00011 00003	(progn 'compile
C00015 ENDMK
C⊗;
;;; A simple Combinator interpreter based on production rules.

(declare (special productions spaces *A *B *C nnodes)
	 (fixsw t)
	 (*lexpr %umatch)
	 (*expr %instantiate)(fixnum spaces))

(eval-when (compile) (load "struct.fas[mac,lsp]"))

(setq nnodes 0)

(defun n-spaces (n)
       (declare (fixnum n))
       (do ((n n (1- n)))
	   ((= n 0))
	   (tyo #o40)))

(defstruct node (parent ())
	   form
	   (sons ()))

(defstruct production 
	  (antecedent ())
	  (consequent ())
	  (action ()))


(defun reduce (form)
       (let ((original form))
	    (terpri)(princ "Reducing: ")(princ form)
	    (print form)
	    (do ((form (process form)
		       (process form))
		 (old-form form form))
		((equal form old-form) 
		 (terpri)
		 (princ original) (princ " = ") (princ form)))))

(defun process (form)
       (cond ((%umatch '(*a (*b) *c)
		       form)
	      (let ((*A *A) 
		    (old-*B *B)
		    (spaces (1+ spaces))
		    (*C *C))
		   (terpri)(n-spaces spaces)
		   (princ spaces)(princ " ")
		   (princ "Processing: ")(princ *B)
		   (setq *B (process *B))
		   (terpri)
		   (n-spaces spaces)(princ spaces)(princ " ")
		   (princ old-*B)(princ " = ")(princ *B))
	      (setq form `(,@*A (,@*B) ,@*C))))
       (do ((productions productions (cdr productions)))
	   ((null productions) 
	    form)
	   (cond ((%umatch
		   (antecedent (car productions))
		   form)
		  (eval (action (car productions)))
		  (setq form (%instantiate (consequent (car productions))))
		  (terpri)(cond ((not (= spaces 0))
				 (n-spaces spaces)
				 (princ spaces)
				 (princ " ")))
		  (princ form)))))

(defun reducible (form1 form2)
       (let ((frontier1 ())
	     (frontier2 ())
	     (node1 (make-node form form1))
	     (node2 (make-node form form2))
	     (nnodes 0))
	    (let ((hist1 
		   (push node1 frontier1))
		  (hist2 
		   (push node2 frontier2)))
		 (do ((intersect ())
		      (nf1 () ())
		      (nf2 () ())
		      (frontier1 frontier1 nf1)
		      (frontier2 frontier2 nf2))
		     ((setq intersect (or (intersection hist1 frontier2)
					  (intersection frontier1 hist2)))
			     (show-results intersect)
		      (terpri)(princ nnodes)(princ " nodes searched."))
		     (do ((frontier1 frontier1 (cdr frontier1)))
			 ((null frontier1))
			 (do ((r
			       (apply1-reduction (form (car frontier1)))
			       (cdr r))
			      (new-node ()))
			     ((null r))
			     (setq new-node (make-node form (car r)
						       parent (car frontier1)))
			     (setq nnodes (1+ nnodes))
			     (push new-node nf1)
			     (setf (sons (car frontier1))
				   `(,new-node .
					       ,(sons (car frontier1))))))
		     (do ((frontier2 frontier2 (cdr frontier2)))
			 ((null frontier2))
			 (do ((r 
			       (apply1-reduction (form (car frontier2))) 
			       (cdr r))
			      (new-node ()))
			     ((null r))
			     (setq new-node (make-node form (car r)
						       parent (car frontier2)))
			     (setq nnodes (1+ nnodes))
			     (push new-node nf2)
			     (setf (sons (car frontier2))
				   `(,new-node .
					       ,(sons (car frontier2))))))))))

(defun report ()
       (terpri)(princ nnodes)(princ " nodes searched."))

(defun apply1-reduction (form)
       (let ((nform ()))
	    (cond ((%umatch '(*a (*b) *c)
			    form)
		   (let ((*A *A) 
			 (*C *C))
			(setq *b (apply1-reduction *B)))
		   (setq nform (mapcar #'(lambda (x)
						 `(,@*A (,@x) ,@*C))
				       *B)))) 
	    (let ((len (length nform)))
		 (cond ((> len 1) nform)
		       ((< len 1) (apply1-reduction1 form))
		       ((equal (car nform) form) (apply1-reduction1 form))
		       (t nform)))))

(defun apply1-reduction1 (nform)
       (do ((productions productions (cdr productions))
	    (forms ()))
	   ((null productions) 
	    forms)
	   (cond ((%umatch
		   (antecedent (car productions))
		   nform)
		  (eval (action (car productions)))
		  (push (%instantiate (consequent (car productions)))
			forms))))))))

(defun intersection (l f)
       (*catch 'intersect (intersect1 l f)))

;;; L is a list of tree nodes; F is the list of frontier nodes.
(defun intersect1 (l f)
       (cond ((null l)())
	     (t (do ((l l (cdr l)))
		    ((null l) ())
		    (do ((f f (cdr f)))
			((null f) ())
			(cond ((equal (form (car l))
				      (form (car f)))
			       (*throw 'intersect `(,(car l) ,(car f)))))))
		(do ((l l (cdr l)))
		    ((null l) ())
		    (intersect1 (sons (car l)) f)))))

(defun show-results (intersect)
       (let ((p1 (parent (car intersect)))
	     (p2 (parent (cadr intersect))))
	    (cond ((and (not p1)(not p2))
		   (print (form (car intersect))))
		  (t
		   (do ((a (car intersect) (parent a))
			(l ()))
		       ((null a) (do ((l l (cdr l)))
				     ((null l))
				     (print (car l))))
		       (push (form a) l))
		   (cond ((and p1 p2)(print '-)))
		   (cond (p2
			  (do ((a p2 (parent a)))
			      ((null a) t)
			      (print (form a)))))))))
(progn 'compile
       (setq productions () spaces 0)
       
       (push (make-production antecedent '(I ?x *t)
			      consequent '(?x *t)) productions)
       
       (push (make-production antecedent '(*h (?x) *t)
			      consequent '(*h ?x *t)) productions)
       
       (push (make-production antecedent '(C ?f ?x ?y *t)
			      consequent '(?f ?y ?x *t)) productions)
       
       (push (make-production antecedent '(W ?f ?x *t)
			      consequent '(?f ?x ?x *t)) productions)
       
       (push (make-production antecedent '(B ?f ?g ?x *t)
			      consequent '(?f (?g ?x) *t)) productions)
       
       (push (make-production antecedent '(K ?x ?y *t)
			      consequent '(?x *t)) productions)
       
       (push (make-production antecedent '(S ?f ?g ?x *t)
			      consequent '(?f ?x (?g ?x) *t)) productions)
       
       (push (make-production antecedent '(PHI ?f ?a ?b ?x *t)
			      consequent '(?f (?a ?x) (?b ?x) *t)) productions)
       
       (push (make-production antecedent '(PSI ?f ?g ?x ?y *t)
			      consequent '(?f (?g ?x) (?g ?y) *t)) productions)
       
       (push (make-production antecedent '((*x) *t)
			      consequent '(*x *t)) productions)
       
       (push (make-production antecedent '((Z 0) *t)
			      consequent '((K I) *t)) productions)
       
       (push (make-production antecedent '((Z ($r ?n (lambda (x)(or (not (numberp x))
								    (not (zerop x))))))
					   *t)
			      consequent '(S B (Z ?n) *t)
			      action '(cond ((numberp ?n)(setq ?n (1- ?n))) 
					    (t (setq ?n `(- ,?n 1))))) productions)
       
       (push (make-production antecedent '((Z (+ ?n 1))
					   *t)
			      consequent '(S B (Z ?n) *t)) productions)
       
       (push (make-production antecedent '(D2 ?x ?y ?z *t)
			      consequent '(?z (K ?y) ?x *t)) productions)
       
       (push (make-production antecedent '(Y ?f *t)
			      consequent '(W S (B W B) ?f *t)) productions)
       
       t)